unit UVonComParser;

interface

uses Windows, MSHTML, ActiveX, Forms, SysUtils, Classes, OleCtrls, SHDocVw,
  Variants, UVonLog;

type
  TEventOfRead = procedure (paramName, value: string) of object;
  TVonHtmlParse = class(TTHread)
  private
    FHtmlDoc: IHTMLDocument2;
    FWebBrowser: TWebBrowser;
    FCurrentItem: IHTMLDOMNode ;
    FCommandList: TStringList;
    FValueList: TStringList;
    FLoopList: TStringList;
    FOnRead: TEventOfRead;
    procedure SetWebBrowser(const Value: TWebBrowser);
    function GetElement(Path: string): IHTMLDOMNode ;
    procedure doCommand;
    function doClick(param: array of string; paramCount: Integer): boolean;
    function doGetAttr(param: array of string; paramCount: Integer): boolean;
    function doNext(param: array of string; paramCount: Integer): boolean;
    function doOpenUrl(param: array of string; paramCount: Integer): boolean;
    function doSleep(param: array of string; paramCount: Integer): boolean;
    function doSetValue(param: array of string; paramCount: Integer): boolean;
    function doGetValue(param: array of string; paramCount: Integer): boolean;
    function doSetAttr(param: array of string; paramCount: Integer): boolean;
    function doGetHtml(param: array of string; paramCount: Integer): boolean;
    function doSetHtml(param: array of string; paramCount: Integer): boolean;
    function doGetText(param: array of string; paramCount: Integer): boolean;
    function doSetText(param: array of string; paramCount: Integer): boolean;
    function Getproperties(name: string): string;
    procedure SetOnRead(const Value: TEventOfRead);
  public
    constructor Create;
    destructor Destory;
    procedure Execute; override;
    function LocateItem(ItemPath: string): boolean;
    function NextItem(): boolean;
    function FirstChild(): boolean;
    function GetAttrValue(Path, AttrName: string): string;
    procedure SetAttrValue(Path, AttrName, Value: string);
    function GetValue(Path: string): string;
    procedure SetValue(Path, Value: string);
    function GetHtml(Path: string): string;
    procedure SetHtml(Path, Value: string);
    function GetText(Path: string): string;
    procedure SetText(Path, Value: string);
    property properties[name: string]: string read Getproperties;
  published
    property WebBrowser: TWebBrowser read FWebBrowser write SetWebBrowser;
    property CommandList: TStringList read FCommandList;
    property OnRead: TEventOfRead read FOnRead write SetOnRead;
  end;

implementation

{ TVonHtmlParse }

constructor TVonHtmlParse.Create;
begin
  FCommandList:= TStringList.Create;
  FValueList:= TStringList.Create;
  FLoopList:= TStringList.Create;
  inherited Create(false);
end;

destructor TVonHtmlParse.Destory;
begin
  FLoopList.Free;
  FValueList.Free;
  FCommandList.Free;
end;

procedure TVonHtmlParse.Execute;
begin
  inherited;
  while true do begin
    while FCommandList.Count = 0 do Suspend;
    if not Assigned(FWebBrowser) then Continue;
    if not Assigned(FWebBrowser.Document) then Continue;
    FHtmlDoc := FWebBrowser.Document as IHTMLDocument2;
    try
      Synchronize(DoCommand);
    except
      on E: Exception do begin
        WriteLog(LOG_FAIL, 'TVonHtmlParse', E.Message);
        Suspend;
      end;
    end;
  end;
end;

procedure TVonHtmlParse.SetWebBrowser(const Value: TWebBrowser);
begin
  FWebBrowser:= Value;
end;

function TVonHtmlParse.GetElement(Path: string): IHTMLDOMNode ;
var
  I, Idx: Integer;
  tags: IHTMLElementCollection;
  paths: TStringList;
begin
  Result:= FCurrentItem;
  if Path = '' then Exit;
  if Path[1] = '/' then
    Result:= FHtmlDoc.body;
  paths:= TStringList.Create;
  paths.Delimiter:= '/';
  paths.DelimitedText:= Path;
  try
    for I := 0 to paths.Count - 1 do begin
      if paths[I] = '' then Continue
      else if Result = nil then Exit
      else if paths[I][1] = '#' then
        Result:= (Result.childNodes as IHTMLElementCollection).item(
          Copy(paths[I], 2, MaxInt), 0) as IHTMLDOMNode
      else if paths[I][1] = '~' then begin
        Idx:= StrToInt(Copy(paths[I], 2, MaxInt));
        tags:= Result.childNodes as IHTMLElementCollection;
        Result:= tags.item(Idx, 0) as IHTMLDOMNode ;
      end else begin
        tags:= (Result.childNodes as IHTMLElementCollection).tags(paths[I]) as IHTMLElementCollection ;
        Result:= tags.item(0, 0) as IHTMLDOMNode ;
      end;
    end;
  finally
    paths.Free;
  end;
end;

(* element functions *)

function TVonHtmlParse.FirstChild: boolean;
var
  tags: IHTMLElementCollection;
begin
  tags:= FCurrentItem.children as IHTMLElementCollection;
  FCurrentItem:= tags.item(1, 0) as IHTMLDOMNode ;
end;

function TVonHtmlParse.GetAttrValue(Path, AttrName: string): string;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  Result:= htmlTag.getAttribute(AttrName, 0);
end;

function TVonHtmlParse.GetHtml(Path: string): string;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  Result:= htmlTag.innerHTML;
end;

function TVonHtmlParse.Getproperties(name: string): string;
begin
  if SameText(name, 'tagName') then Result:= FCurrentItem.tagName
  else if SameText(name, 'id') then Result:= FCurrentItem.id
  else if SameText(name, 'index') then Result:= IntToStr(FCurrentItem.sourceIndex);
end;

function TVonHtmlParse.GetText(Path: string): string;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  Result:= htmlTag.innerText;
end;

function TVonHtmlParse.GetValue(Path: string): string;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  Result:= htmlTag.getAttribute('value', 0);
end;

function TVonHtmlParse.LocateItem(ItemPath: string): boolean;
var
  tag: IHTMLDOMNode ;
begin
  FCurrentItem:= GetElement(ItemPath);
  Result:= Assigned(FCurrentItem);
end;

function TVonHtmlParse.NextItem: boolean;
var
  tags: IHTMLElementCollection;
  Idx: Integer;
  htmlTag: IHTMLDOMNode;
begin
  htmlTag:= IHTMLDOMNode(FCurrentItem);
  FCurrentItem:= htmlTag.nextSibling;
  Result:= Assigned(FCurrentItem);
end;

procedure TVonHtmlParse.SetAttrValue(Path, AttrName, Value: string);
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  htmlTag.attributes(AttrName, Value, 0);
end;

procedure TVonHtmlParse.SetHtml(Path, Value: string);
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  htmlTag.nodeValue:= Value;
end;

procedure TVonHtmlParse.SetOnRead(const Value: TEventOfRead);
begin
  FOnRead := Value;
end;

procedure TVonHtmlParse.SetText(Path, Value: string);
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  htmlTag.innerText:= Value;
end;

procedure TVonHtmlParse.SetValue(Path, Value: string);
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(Path);
  if not Assigned(htmlTag) then Exit;
  htmlTag.setAttribute('value', Value, 0);
end;
(* Commands *)
procedure TVonHtmlParse.doCommand;
var
  P, PV: PChar;
  cmd, szValue: string;
  param: array[0..5]of string;
  idx: Integer;

  function GetmarkValue(): string;
  var
    Mark: char;
  begin
    Mark:= P^; Inc(P); Result:= '';
    while P^ <> #0 do begin
      if P^ = Mark then begin
        Inc(P);
        if(P^ = #0)or(P^ <> Mark)then Exit;
      end else Result:= Result + P^;
      Inc(P);
    end;
  end;
begin
  inherited;
  P:= PChar(FCommandList[0]);
  cmd:= ''; szValue:= ''; idx:= 0; PV:= nil;
  while P^ <> #0 do begin
    case P^ of
    ' ': if cmd = '' then begin Cmd:= szValue; szValue:= ''; end
      else szValue:= szValue + P^;
    ',': begin param[Idx]:= szValue; Inc(Idx); szValue:= ''; end;
    '<': PV:= P;
    '>': if not Assigned(PV) then
        szValue:= szValue + P^
      else begin
        szValue:= szValue + FValueList.Values[Copy(string(PV), 2, P - PV - 1)];
        PV:= nil;
      end;
    '"', '''': if szValue = '' then szValue:= szValue + GetmarkValue();
    else if not Assigned(PV) then
      szValue:= szValue + P^;
    end;
    Inc(P);
  end;
  if cmd = '' then Cmd:= szValue
  else param[Idx]:= szValue;
  if SameText(cmd, 'open') then begin                   //Open <url>
    if not doOpenUrl(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'Click') then begin         //Click <itemID>
    if not doClick(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'Sleep') then begin         //Sleep <Sleeptime>
    if not doSleep(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'Locate') then begin        //Locate
    if not LocateItem(param[0]) then Suspend;
  end else if SameText(cmd, 'Next') then begin          //Next
    if not NextItem then Suspend;
  end else if SameText(cmd, 'Suspend') then begin       //Suspend
    Suspend;
  end else if SameText(cmd, 'Refresh') then begin       //Refresh
    if Assigned(FWebBrowser) then FWebBrowser.Refresh;
  end else if SameText(cmd, 'GetAttr') then begin       //GetAttr <path>,<attrName>,<nameToSave>
    if not doGetAttr(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'GetValue') then begin      //GetValue <path>,<nameToSave>
    if not doGetValue(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'SetAttr') then begin       //SetAttr <itemID>,<attrName>,<Value>
    if not doSetAttr(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'SetValue') then begin      //SetValue <itemID>,<Value>
    if not doSetValue(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'GetHtml') then begin       //GetHtml <itemID>,<nameToSave>
    if not doGetHtml(param, Idx + 1) then Suspend;
  end else if SameText(cmd, 'GetText') then begin       //GetText <itemID>,<Value>
    if not doGetText(param, Idx + 1) then Suspend;
  end;
  FCommandList.Delete(0);
end;
//Click <itemID>
function TVonHtmlParse.doClick(param: array of string; paramCount: Integer): boolean;
begin
  Result:= False;
  if LocateItem(param[0]) then
    FCurrentItem.click;
  Result:= True;
end;
//AttrValue <path>,<attrName>,<nameToSave>
function TVonHtmlParse.doGetAttr(param: array of string; paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  if param[2][1] = '#' then begin
    if Assigned(FOnRead) then
      FOnRead(Copy(param[2], 2, MaxInt), htmlTag.getAttribute(param[1], 0));
  end else FValueList.Values[param[1]]:= htmlTag.getAttribute(param[1], 0);
  Result:= True;
end;
//GetHtml <itemID>,<nameToSave>
function TVonHtmlParse.doGetHtml(param: array of string; paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  if param[1][1] = '#' then begin
    if Assigned(FOnRead) then
      FOnRead(Copy(param[1], 2, MaxInt), htmlTag.innerHTML);
  end else FValueList.Values[param[1]]:= htmlTag.innerHTML;
  Result:= True;
end;
//GetText <itemID>,<nameToSave>
function TVonHtmlParse.doGetText(param: array of string;
  paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  if param[1][1] = '#' then begin
    if Assigned(FOnRead) then
      FOnRead(Copy(param[1], 2, MaxInt), htmlTag.innerText);
  end else FValueList.Values[param[1]]:= htmlTag.innerText;
  Result:= True;
end;
//AttrValue <path>,<nameToSave>
function TVonHtmlParse.doGetValue(param: array of string; paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  if param[1][1] = '#' then begin
    if Assigned(FOnRead) then
      FOnRead(Copy(param[1], 2, MaxInt), htmlTag.getAttribute('value', 0));
  end else FValueList.Values[param[1]]:= htmlTag.getAttribute('value', 0);
  Result:= True;
end;
//Next
function TVonHtmlParse.doNext(param: array of string;
  paramCount: Integer): boolean;
var
  tags: IHTMLElementCollection;
begin
  tags:= FCurrentItem.parentElement.children as IHTMLElementCollection;
  FCurrentItem:= tags.item(FCurrentItem.sourceIndex + 1, 0) as IHTMLDOMNode ;
  Result:= Assigned(FCurrentItem);
end;
//Open <url>
function TVonHtmlParse.doOpenUrl(param: array of string; paramCount: Integer): boolean;
begin
  if Assigned(FWebBrowser) then
    FWebBrowser.Navigate(param[0]);
  Result:= True;
end;
//SetAttr <path>,<attrName>,<Value>
function TVonHtmlParse.doSetAttr(param: array of string;
  paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  htmlTag.setAttribute(param[1], param[2], 0);
  Result:= True;
end;
//SetHtml <path>,<Value>
function TVonHtmlParse.doSetHtml(param: array of string;
  paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  htmlTag.innerHTML:= param[1];
  Result:= True;
end;
//SetText <path>,<Value>
function TVonHtmlParse.doSetText(param: array of string;
  paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  htmlTag.innerText:= param[1];
  Result:= True;
end;
//SetValue <path>,<Value>
function TVonHtmlParse.doSetValue(param: array of string; paramCount: Integer): boolean;
var
  htmlTag: IHTMLDOMNode ;
begin
  htmlTag:= GetElement(param[0]);
  if not Assigned(htmlTag)then Exit;
  htmlTag.setAttribute('value', param[1], 0);
  Result:= True;
end;
//Sleep <Seconds>
function TVonHtmlParse.doSleep(param: array of string; paramCount: Integer): boolean;
begin
  Sleep(StrToInt(Param[0]) * 1000);
  Result:= True;
end;
end.
